

; Utility Functions
; small procedures that wouldnt fit anywhere else



(load "optimization.scm")
(load "vector.scm") ; for vector-copy!
(require scheme)    ; for for



; Delegate
; macro that passes a method call to a member variable
(define-syntax-rule (delegate method object)
  (define/public (method . args)
    (send object method . args)))

; Make Size
; calls get-width/get-height and creates a size vector
(define (make-size object)
  (vector (send object get-width) (send object get-height)))



; If Min
(define (if-min . args)
  (let if-min-loop ([current (cdr args)]
                    [res (car args)])
    (if (null? current)
        res
        (if-min-loop (cdr current) (if (number? (car current))
                                       (if (number? res)
                                           (min (car current) res)
                                           (car current))
                                       res)))))


; Current Second
(define (current-second)
  (fl/ (current-milliseconds) #i1000))





; Debug Reset
(define (debug-reset)
  (set! *debug-pos* #i0))

; Debug
(define (debug dc string)
  (send dc set-text-foreground (send the-color-database find-color "Green"))
  (send dc set-font (make-object font% 8 'modern 'normal 'bold))
  (send dc draw-text string #i10 (fl+ #i10 (* (* #i8 #i3/2) *debug-pos*)))
  (set! *debug-pos* (add1 *debug-pos*)))

; Display* multiple arguments
(define (display* . args)
  (for-each (lambda (arg) (display arg)) args))






; Mutable List
(define (mlist . args)
  (let mlist-loop ([current args]
                   [res  '()])
    (if (null? current)
        res
        (mcons (car current) (mlist-loop (cdr current) res)))))

; Mutable Remove
(define (mremove value ml)
  (let mremove-loop ([current ml]
                     [prev    '()])
    (if (null? current)
        ml
        (if (eq? (mcar current) value)
            (if (null? prev)
                (mcdr ml)
                (begin
                  (set-mcdr! prev (mcdr current))
                  ml))
            (mremove-loop (mcdr current) current)))))

; Mutable Length
(define (mlength ml)
  (let mlength-loop ([current ml]
                     [res 0])
    (if (null? current)
        res
        (mlength-loop (mcdr current) (add1 res)))))

; Mutable For-Each
(define (mfor-each op ml)
  (let mfor-each-loop ([current ml])
    (unless (null? current)
      (op (mcar current))
      (mfor-each-loop (mcdr current)))))

; Mutable Assoc
(define (massoc value ml)
  (let massoc-loop ([current ml])
    (if (null? current)
        #f
        (if (equal? (mcar (mcar current)) value)
            (mcar current)
            (massoc-loop (mcdr current))))))

; Vector For-Each
(define (vector-for-each op v)
  (for ([pos (in-range (vector-length v))])
    (op pos (vector-ref v pos))))


; Vector Allocate
(define (vector-allocate vec pos value)
  (if (and vec (< pos (vector-length vec)))
      vec
      (let ([new-vec (make-vector (add1 pos) value)])
        (when vec
          (vector-copy! new-vec 0 vec))
        new-vec)))







; Clamp
(define (clamp lower upper value)
  (max lower (min upper value)))

; Rotate In Range
(define (rotate-in-range size value)
  (let rotate-in-range-loop ([res value])
    (if (< res 0)
        (rotate-in-range-loop (+ res size))
        (if (>= res size)
            (rotate-in-range-loop (- res size))
            res))))

; Point to index
(define (point->index x y width)
  (+ x (* y width)))







; String Find First
(define (string-find-first str char)
  (let ([len (string-length str)])
    (let string-find-first-loop ([pos 0])
      (if (= pos len)
          #f
          (if (eq? char (string-ref str pos))
              pos
              (string-find-first-loop (add1 pos)))))))

; String Char Replace
(define (string-char-replace str proc)
  (let ([len (string-length str)])
    (let string-replace-loop ([pos 0]
                              [ret ""])
      (if (= pos len)
          ret
          (string-replace-loop (add1 pos) (string-append ret (proc (string-ref str pos))))))))


; String Extract Number
; extracts non-negative integer until "unreadable" character
(define (string-extract-number str)
  (let ([len  (string-length str)]
        [base (char->integer #\0)])
    (let string-extract-number-loop ([pos 0]
                                     [res #f])
      (if (= pos len)
          res
          (let ([number (- (char->integer (string-ref str pos)) base)])
            (if (or (< number 0) (> number 9))
                (values res (substring str pos))
                (string-extract-number-loop (add1 pos) (+ number (* 10 (if res res 0))))))))))






; Bitmap Edit Pixels
; returns a new bitmap with pixels equaling the return of op applied to pixels in given bitmap
(define (bitmap-edit-pixels bitmap op)
  (let* ([width      (send bitmap get-width)]
         [height     (send bitmap get-height)]
         [read       (make-bytes (* 4 width height))]
         [read-mask  (send bitmap get-loaded-mask)]
         [res        (make-object bitmap% width height)]
         [write-mask (make-object bitmap% width height)]
         [dc         (make-object bitmap-dc%)])
    ; read into buffer
    (send       bitmap                  get-argb-pixels 0 0 width height read #f)
    (when read-mask
      (send read-mask get-argb-pixels 0 0 width height read #t))
    ; edit pixels
    (let ([write (op width height read)])
      ; set rgb in result
      (send dc set-bitmap res)
      (send dc set-argb-pixels 0 0 width height write #f)
      ; combine with alpha in mask
      (when read-mask
        (send dc set-bitmap write-mask)
        (send dc set-argb-pixels 0 0 width height write #t)
        (send res set-loaded-mask write-mask))
      ; clean
      (send dc set-bitmap #f)
      ; return
      res)))

; Bitmap Mirror Flip
(define (bitmap-mirror-flip bitmap mirror flip)
  (bitmap-edit-pixels bitmap (lambda (width height read)
                               (let ([write (make-bytes (* 4 width height))])
                                 (for ([x (in-range width)])
                                   (for ([y (in-range height)])
                                     (for ([b (in-range 4)])
                                       (bytes-set! write (+ b (* 4 (point->index (if mirror (- (sub1 width) x) x) (if flip (- (sub1 height) y) y) width)))
                                                   (bytes-ref read (+ b (* 4 (point->index x y width))))))))
                                 write))))

; Bitmap Pixel Scale
(define (bitmap-pixel-scale bitmap a r g b)
  (bitmap-edit-pixels bitmap (lambda (width height read)
                               (for ([i (in-range (* width height))])
                                 (bytes-set! read (+ 0 (* 4 i)) (fxquotient (fx* a (bytes-ref read (+ 0 (* 4 i)))) 255))
                                 (bytes-set! read (+ 1 (* 4 i)) (fxquotient (fx* r (bytes-ref read (+ 1 (* 4 i)))) 255))
                                 (bytes-set! read (+ 2 (* 4 i)) (fxquotient (fx* g (bytes-ref read (+ 2 (* 4 i)))) 255))
                                 (bytes-set! read (+ 3 (* 4 i)) (fxquotient (fx* b (bytes-ref read (+ 3 (* 4 i)))) 255)))
                               read)))

